home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / tpb4_src.zip / MSGENTR.PAS < prev    next >
Pascal/Delphi Source File  |  1988-09-13  |  20KB  |  626 lines
  1. { TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
  2.   Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault
  3.   
  4.   Last modified  ::  7-30-88 22:00 pm
  5. }
  6.  
  7. {$R-}                             {Range checking off}
  8. {$B-}                             {Boolean complete evaluation off}
  9. {$S-}                             {Stack checking off}
  10. {$I+}                             {I/O checking on}
  11. {$N-}                             {No numeric coprocessor}
  12.  
  13. Unit MsgEntr;
  14.  
  15. Interface
  16.  
  17. Uses
  18.   TPCrt, Dos, Globals, Core1, Core2,
  19.   TAccess, TPSTRING, Misc, MsgBuild;
  20.   
  21.   
  22. procedure mesg_enter(to_ctrl : Char);
  23.  
  24.  
  25.   {==========================================================================}
  26.   
  27.   
  28. Implementation
  29.  
  30.  
  31.   procedure mesg_enter(to_ctrl : Char);
  32.     { Enter a new message }
  33.     
  34.   type
  35.     TextPtr         = ^TextRecord;
  36.     TextRecord =
  37.       record
  38.         LineNo          : Integer; { Line number }
  39.         TextMsg         : message; { Summary index }
  40.         next            : TextPtr { Pointer to next element on list }
  41.       end;
  42.       
  43.   var
  44.     stop_msg,
  45.     abort,
  46.     not_saved       : Boolean;
  47.     msg_status      : record_status;
  48.     ch              : Char;
  49.     last_line,
  50.     to_area         : Integer;
  51.     to_loc          : LongInt;
  52.     TextBase,
  53.     TextLast, This  : TextPtr;
  54.     ThisArea        : AreaPtr;
  55.     to_fn           : FirstName;
  56.     to_ln           : LastName;
  57.     subj            : subject;
  58.     key             : StrName;
  59.     temp_user_rec   : user_list;
  60.     subj_prompt     : StrStd;
  61.     mname           : Str13;
  62.     to_temp         : Str36;
  63.     to_area_name    : DosFileName;
  64.     
  65.     
  66.     function In_Conference : Boolean;
  67.     
  68.     var
  69.       i               : Integer;
  70.       This            : AreaPtr;
  71.       
  72.     begin
  73.       This := AreaBase;
  74.       i := 0;
  75.       while (This <> nil) and (This^.AreaName <> AreaReq) do
  76.         This := This^.next;
  77.       if This^.AreaName = AreaReq then
  78.         i := This^.AreaConf and 7;
  79.       In_Conference := test_bit(user_rec.conf_flags, i);
  80.     end;
  81.     
  82.     
  83.     procedure mesg_input(var last_line : Integer);
  84.       { Input message }
  85.       
  86.     var
  87.       ch              : Char;
  88.       This            : TextPtr;
  89.       msg             : StrStd;
  90.       
  91.     begin
  92.       abort := False;
  93.       WriteLn(com);
  94.       msg := ' ';
  95.       next_inpstr := '';
  96.       while (not brk) and (msg <> '') and (Online) do
  97.         begin
  98.           msg := next_inpstr;
  99.           if (last_line+1 = max_msg_lines) and (limit_lines) then
  100.             WriteLn(com, 'Two Lines Left');
  101.           if (last_line > max_msg_lines) and (limit_lines) then
  102.             msg := ''
  103.           else
  104.             begin
  105.               Write(com, last_line:2, '> ');
  106.               GetStr(msg, ch, len_msg, 'AEW');
  107.               WriteLn(com);
  108.             end;
  109.           if msg <> '' then
  110.             if MaxAvail > 400 then
  111.               begin
  112.                 New(This);
  113.                 if TextBase = nil then
  114.                   TextBase := This
  115.                 else
  116.                   TextLast^.next := This;
  117.                 TextLast := This;
  118.                 TextLast^.LineNo := last_line;
  119.                 TextLast^.TextMsg := msg;
  120.                 TextLast^.next := nil;
  121.                 Inc(last_line)
  122.               end
  123.             else
  124.               begin
  125.                 WriteLn(com, 'Memory full.');
  126.                 msg := ''
  127.               end
  128.         end
  129.     end;
  130.     
  131.     
  132.     procedure mesg_edit;
  133.       { Edit selected line from message }
  134.       
  135.     var
  136.       ch              : Char;
  137.       i               : Integer;
  138.       This, prev      : TextPtr;
  139.       msg             : StrStd;
  140.       
  141.     begin
  142.       WriteLn(com);
  143.       Write(com, 'Edit message line...');
  144.       i := strint(prompt('Number', 2, 'E'));
  145.       This := TextBase;
  146.       prev := TextBase;
  147.       if i > 0 then
  148.         begin
  149.           while (i <> This^.LineNo) and (This <> nil) do {find line}
  150.             begin
  151.               prev := This;
  152.               This := This^.next;
  153.             end;
  154.           if This <> nil then
  155.             begin
  156.               msg := This^.TextMsg;
  157.               Write(com, i:2, '> ');
  158.               GetStr(msg, ch, len_msg, 'EL');
  159.               WriteLn(com);
  160.               if msg <> '' then
  161.                 This^.TextMsg := msg;
  162.             end
  163.           else
  164.             WriteLn(com, 'Not found.')
  165.         end;                      {i>0}
  166.     end;
  167.     
  168.     
  169.     procedure mesg_delete;
  170.       { Delete selected lines from message }
  171.       
  172.     var
  173.       i, n            : Integer;
  174.       This, prev      : TextPtr;
  175.       
  176.     begin
  177.       WriteLn(com);
  178.       i := strint(prompt('Delete line number', 2, 'E'));
  179.       n := strint(prompt('    through number', 2, 'E'))+1;
  180.       if n > last_line then
  181.         n := last_line;
  182.       n := n-i;
  183.       if (i > 0) and (n > 0) then
  184.         repeat
  185.           This := TextBase;
  186.           prev := TextBase;
  187.           while (i <> This^.LineNo) and (This <> nil) do {find line}
  188.             begin
  189.               prev := This;
  190.               This := This^.next;
  191.             end;
  192.           if This <> nil then
  193.             begin
  194.               if (prev = TextBase) and (prev = This) then
  195.                 TextBase := This^.next
  196.               else
  197.                 prev^.next := This^.next;
  198.               Dispose(This);
  199.               if TextLast = This then
  200.                 TextLast := prev;
  201.               This := prev^.next;
  202.               while This <> nil do
  203.                 begin
  204.                   This^.LineNo := Pred(This^.LineNo);
  205.                   TextLast := This;
  206.                   This := This^.next;
  207.                 end;
  208.               Dec(last_line);
  209.               Dec(n);
  210.             end
  211.           else
  212.             begin
  213.               WriteLn(com, 'Not found.');
  214.               n := 0
  215.             end;
  216.         until n = 0;              {i>0}
  217.     end;
  218.     
  219.     
  220.     
  221.     procedure mesg_insert_line;
  222.       {insert a line into text  modified by ret  -- 7/24/88}
  223.     var
  224.       ch              : Char;
  225.       i, line_count   : Integer;
  226.       This, prev, new_line : TextPtr;
  227.       msg             : StrStd;
  228.       
  229.     begin
  230.       WriteLn(Com);
  231.       i := strint(prompt('Insert before line...Number', 2, 'E'));
  232.       This := TextBase;
  233.       prev := TextBase;
  234.       if i > 0 then
  235.         begin
  236.           while (i <> This^.LineNo) and (This <> nil) do {find line}
  237.             begin
  238.               prev := This;
  239.               This := This^.next;
  240.             end;
  241.           if This <> nil then
  242.             begin
  243.               if (prev = TextBase) and (prev = This) then
  244.                 TextBase := nil   {inserting at very BEGINning}
  245.               else
  246.                 TextLast := prev; {END of top part of break}
  247.               line_count := i;    {save line count to current line}
  248.               mesg_input(i);      {insert (input) new lines}
  249.                     TextLast^.next := This; {connect tail of mesg to
  250.                                                       the newly inserted lines}
  251.               line_count := i-line_count; {calculate # of new lines}
  252.               while This <> nil do
  253.                 begin
  254.                   This^.LineNo := This^.LineNo+line_count;
  255.                   TextLast := This;
  256.                   This := This^.next;
  257.                 end;
  258.               Last_line := Last_line+line_count {update total line count}
  259.             end
  260.           else
  261.             WriteLn(Com, 'Not found.')
  262.         end;                      {i>0}
  263.     end;
  264.     
  265.     
  266.     
  267.     procedure mesg_print;
  268.       { Display message currently being edited }
  269.       
  270.     var
  271.       This            : TextPtr;
  272.       
  273.     begin
  274.       WriteLn(com);
  275.       if user_rec.fn <> 'SYSOP' then
  276.         WriteLn(com, 'From: ', UserFullName)
  277.       else
  278.         WriteLn(com, 'From: Sysop');
  279.       if to_fn = '' then
  280.         WriteLn(com, '  To: All')
  281.       else
  282.         begin
  283.           st := to_fn+' '+to_ln;
  284.           caps_to_mixed(st);
  285.           WriteLn(com, '  To: ', st);
  286.         end;
  287.       WriteLn(com, '  Re: ', subj);
  288.       WriteLn(com);
  289.       This := TextBase;
  290.       while (not brk) and (This <> nil) do
  291.         begin
  292.           WriteLn(com, This^.LineNo:2, ': ', This^.TextMsg);
  293.           This := This^.next
  294.         end
  295.     end;
  296.     
  297.     
  298.     procedure mesg_save(to_loc : LongInt; subj : subject; var stop_msg : Boolean);
  299.       { Save message to disk }
  300.       
  301.     var
  302.       Start,
  303.       line_count      : Integer;
  304.       This            : TextPtr;
  305.       file_time       : tad_array;
  306.       Str             : StrTAD;
  307.       
  308.     begin
  309.       WriteLn(com);
  310.       if (msg_status = private) and (test_bit(user_rec.flags, 2)) then
  311.         msg_status := restricted;
  312.       if (msg_status = private) and (user_rec.access >= val_acc) and (valid_pw) and (not test_bit
  313.         (user_rec.flags,
  314.           3)) then
  315.         if ask('Do you want this message to be public', 'N') then
  316.           begin
  317.             if restrict_public then
  318.               msg_status := restricted
  319.             else
  320.               msg_status := public;
  321.           end;
  322.       if msg_status = restricted then
  323.         WriteLn(com, 'Msg. available after Sysop Approval');
  324.       Start := FileSize(mesg_file);
  325.       Seek(mesg_file, Start);
  326.       line_count := 0;
  327.       This := TextBase;
  328.       while This <> nil do
  329.         begin
  330.           Write(mesg_file, This^.TextMsg);
  331.           Inc(line_count);
  332.           This := This^.next
  333.         end;
  334.       if line_count > 0 then
  335.         begin
  336.           GetTAD(file_time);
  337.           Str := FormTAD(file_time);
  338.           if Str = 'No Date' then
  339.             FillChar(file_time, SizeOf(file_time), 0);
  340.           Seek(summ_file, 0);
  341.           Read(summ_file, summ_rec);
  342.           with summ_rec do
  343.             begin
  344.               date := file_time;
  345.               status := msg_status;
  346.               Area := to_area;
  347.               Inc(num);           { message number}
  348.               num_prev := 0;      {for protecting pvt. msgs until released}
  349.               num_next := user_rec.access;
  350.               user_from := user_loc;
  351.               user_to := to_loc;
  352.               subject := subj;
  353.               st_rec := Start;
  354.               size := line_count
  355.             end;
  356.             
  357.           Seek(summ_file, 0);
  358.           Write(summ_file, summ_rec);
  359.           Seek(summ_file, FileSize(summ_file));
  360.           Write(summ_file, summ_rec);
  361.           mesg_insert(2);
  362.           case msg_status of
  363.             private :
  364.               Write(com, 'Private');
  365.             public, restricted :
  366.               Write(com, 'Public')
  367.           end;
  368.           WriteLn(com, ' message ', summ_rec.num, ' filed ', Str)
  369.         end
  370.       else
  371.         WriteLn(com, 'Message not filed.');
  372.       stop_msg := True
  373.     end;
  374.     
  375.     
  376.     procedure mesg_quit(var stop_msg : Boolean);
  377.       { Return to command mode }
  378.       
  379.     begin
  380.       WriteLn(com);
  381.       WriteLn(com, 'Message not filed.');
  382.       stop_msg := True;
  383.       mult_cmds := False;
  384.       Cmd_Queue := '';
  385.     end;
  386.     
  387.     
  388.     
  389.   begin                           {message enter}
  390.     abort := False;
  391.     to_area_name := '';
  392.     if (((diskfree(Ord(Upcase(HomDrv[1]))-64)) div 1024) > maxfree_abs) or
  393.     (not test_bit(user_rec.flags, 4)) then
  394.       begin
  395.         if (diskfree(Ord(Upcase(HomDrv[1]))-64) div 1024) <= maxfree_mslimit then
  396.           begin
  397.             limit_lines := True;
  398.             max_msg_lines := maxfree_lines; {restrict because not enough space left on disk}
  399.           end;
  400.         if (user_rec.access < val_acc) and valid_pw then
  401.           list('D');
  402.         WriteLn(com);
  403.         if user_rec.fn <> 'SYSOP' then
  404.           WriteLn(com, 'From: ', UserFullName)
  405.         else
  406.           WriteLn(com, 'From: Sysop');
  407.         OK := False;
  408.         if In_Conference then
  409.           msg_status := public
  410.         else
  411.           msg_status := private;
  412.         repeat
  413.           if (user_rec.access < val_acc) or (to_ctrl = 'S') or ((to_ctrl = 'A') and (summ_rec.
  414.             user_from = 0)) then
  415.             begin
  416.               to_fn := 'SYSOP';
  417.               WriteLn(com, '  To: ', 'Sysop');
  418.               to_area := 1;       {Post area}
  419.             end
  420.           else if (to_ctrl = 'A') and (summ_rec.user_from > 0) then
  421.             begin
  422.               to_loc := summ_rec.user_from;
  423.               to_area := summ_rec.Area;
  424.               ThisArea := AreaBase;
  425.               while ThisArea^.Area <> to_area do
  426.                 ThisArea := ThisArea^.next;
  427.               to_area_name := ThisArea^.AreaName;
  428.               OK := True;
  429.               GetRec(DatF, to_loc, temp_user_rec);
  430.               to_fn := temp_user_rec.fn;
  431.               to_ln := temp_user_rec.ln;
  432.               st := to_fn+' '+to_ln;
  433.               caps_to_mixed(st);
  434.               WriteLn(com, '  To: ', st)
  435.             end
  436.           else if (to_ctrl = 'M') then
  437.             begin
  438.               to_loc := nwin_rec.user;
  439.               to_area := 1;
  440.               OK := True;
  441.               GetRec(DatF, to_loc, temp_user_rec);
  442.               to_fn := temp_user_rec.fn;
  443.               to_ln := temp_user_rec.ln;
  444.               st := to_fn+' '+to_ln;
  445.               caps_to_mixed(st);
  446.               WriteLn(com, '  To: ', st)
  447.             end
  448.           else
  449.             begin
  450.               to_ln := '';
  451.               st := prompt('To FULL name [CR for ALL]', len_name, 'EL');
  452.               st := StUpcase(st);
  453.               if Pos(' ', st) <> 0 then
  454.                 begin
  455.                   to_ln := Copy(st, (Succ(Pos(' ', st))), len_name);
  456.                   Delete(st, (Pos(' ', st)), len_name);
  457.                   to_fn := st
  458.                 end
  459.               else
  460.                 begin
  461.                   to_ln := '';
  462.                   to_fn := st
  463.                 end;
  464.               if to_fn = 'QUIT' then
  465.                 abort := True;
  466.               if to_fn = 'ALL' then
  467.                 to_fn := '';
  468.               if (user_rec.fn = 'SYSOP') and (AreaSet = 0) then
  469.                 to_area := 1
  470.               else
  471.                 to_area := AreaSet;
  472.             end;
  473.           if to_fn = '' then
  474.             begin
  475.               to_loc := 0;
  476.               if (restrict_public or test_bit(user_rec.flags, 3)) and (not In_Conference)
  477.               then
  478.                 msg_status := restricted
  479.               else
  480.                 msg_status := public;
  481.               OK := True
  482.             end
  483.           else if to_fn = 'SYSOP' then
  484.             to_ln := ''
  485.           else if (to_ctrl <> 'A') and (not abort) and (to_ln = '') then
  486.             begin
  487.               to_ln := prompt('LAST name', len_ln, 'EL');
  488.               to_ln := StUpcase(to_ln);
  489.               if to_ln = 'QUIT' then
  490.                 abort := True;
  491.             end;
  492.           if (not OK) and (not abort) then
  493.             begin
  494.               if to_fn+' '+to_ln = fido_sysop then
  495.                 begin
  496.                   to_fn := 'SYSOP';
  497.                   to_ln := ''
  498.                 end;
  499.               key := pad(to_ln, len_ln)+pad(to_fn, len_fn);
  500.               FindKey(IdxF, to_loc, key);
  501.               if not OK then
  502.                 begin
  503.                   WriteLn(com, to_fn, ' ', to_ln, ' not known on system.');
  504.                   WriteLn(com, 'type QUIT to exit .');
  505.                 end;
  506.             end;
  507.         until (not Online) or OK or abort;
  508.         if abort then
  509.           OK := False;
  510.         if OK then
  511.           begin
  512.             if not valid_pw then
  513.               begin
  514.                 subj := 'Password problem';
  515.                 WriteLn(com, '  Re: ', subj)
  516.               end
  517.             else if user_rec.access < val_acc then
  518.               begin
  519.                 subj := 'New user';
  520.                 WriteLn(com, '  Re: ', subj)
  521.               end
  522.             else if to_ctrl = 'A' then
  523.               begin
  524.                 subj_prompt := summ_rec.subject;
  525.                 Write(com, '  Re: ');
  526.                 GetStr(subj_prompt, ch, len_subj, 'EL');
  527.                 subj := subj_prompt;
  528.                 WriteLn(com);
  529.               end
  530.             else if to_ctrl = 'M' then
  531.               begin
  532.                 subj := 'Your Upload - '+nwin_rec.name;
  533.                 WriteLn(com, '  Re: ', subj);
  534.               end
  535.             else
  536.               subj := prompt('Subject', len_subj, 'EL');
  537.             if subj = '' then
  538.               subj := 'NONE';
  539.             WriteLn(com);
  540.             TextBase := nil;
  541.             last_line := 1;
  542.             if local_online and valid_pw then
  543.               begin
  544.                 if to_fn = '' then
  545.                   to_temp := 'ALL'
  546.                 else
  547.                   to_temp := to_fn+' '+to_ln;
  548.                 {$V-}
  549.                 caps_to_mixed(to_temp) {$V+} ;
  550.                 DispName := '   To: '+to_temp;
  551.                 if to_area_name <> '' then
  552.                   mname := to_area_name
  553.                 else if AreaReq = 'SYSTEM' then
  554.                   mname := 'POST'
  555.                 else
  556.                   mname := AreaReq;
  557.                 WriteLn(com);
  558.                 mname := Copy(mname, 1, 8);
  559.                 full_screen_edit(mname+'.MSG', 'W', not_saved);
  560.                 make_message(mname, to_fn, to_ln, subj);
  561.               end
  562.             else
  563.               begin
  564.                 if limit_lines then
  565.                   begin
  566.                     WriteLn(com, 'Message is limited to ', max_msg_lines, ' lines.');
  567.                     WriteLn(com);
  568.                   end;
  569.                 WriteLn(com, 'When Message finished, enter an empty line. <CR>');
  570.                 WriteLn(com, 'Ready for message...');
  571.                 mesg_input(last_line);
  572.               end;
  573.             stop_msg := False;
  574.             if (TextBase <> nil) then
  575.               begin
  576.                 repeat
  577.                   WriteLn(com);
  578.                   st := prompt('Edit command <C><D><E><I><L><S><Q><?>', 80, 'ES?');
  579.                   if Length(st) = 1 then
  580.                     ch := st[1]
  581.                   else
  582.                     st := ' ';
  583.                   case ch of
  584.                     'C' :
  585.                       mesg_input(last_line);
  586.                     'D' :
  587.                       mesg_delete;
  588.                     'E' :
  589.                       mesg_edit;
  590.                     'I' :
  591.                       mesg_insert_line;
  592.                     'L' :
  593.                       mesg_print;
  594.                     'S' :
  595.                       mesg_save(to_loc, subj, stop_msg);
  596.                     'Q' :
  597.                       mesg_quit(stop_msg)
  598.                   else
  599.                     list('E');
  600.                   end;
  601.                 until (not Online) or (stop_msg and (ch in ['C', 'D', 'E', 'I', 'L', 'S',
  602.                   'Q']));
  603.               end
  604.             else if (not local_online) then
  605.               WriteLn(com, 'Unable to continue message  - aborting. ');
  606.             while TextBase <> nil do
  607.               begin
  608.                 This := TextBase; { Get rid of list elements }
  609.                 TextBase := TextBase^.next;
  610.                 Dispose(This)
  611.               end;
  612.           end;                    {OK}
  613.       end                         {enough disk space and allowed}
  614.     else
  615.       begin
  616.         if test_bit(user_rec.flags, 4) then
  617.           WriteLn(com, 'Unable to accept messages.')
  618.         else
  619.           WriteLn(com, 'Not enough disk space for messages.');
  620.       end;
  621.   end;
  622.   
  623.   
  624. end.                              { of MSGENTR.PAS}
  625. 
  626.